(*
 *  MTASC - MotionTwin ActionScript2 Compiler
 *  Copyright (c)2004 Nicolas Cannasse
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

open Expr
open Swf
open ExtHashtbl

type kind = 
	| VarReg of int
	| VarStr
	| VarObj
	| VarGetSet of string

type local_ctx = {
	reg : int;
	sp : int;
}

type context =  {
	idents : (string,int) Hashtbl.t;
	ops : action DynArray.t;
	super_bindings : (type_path * string,bool) Hashtbl.t;
	locals : (string,local_ctx) Hashtbl.t;
	main : type_path option ref;
	mutable current : Class.context;
	mutable stack : int;
	mutable code_pos : int;
	mutable ident_count : int;
	mutable reg_count : int;
	mutable stack_size : int;
	mutable cur_block : expr;
	mutable breaks : (unit -> unit) list;
	mutable continue_pos : int;
	mutable opt_push : bool;
	mutable curmethod : string;
	mutable forins : int;
}

type push_style =
	| VStr of string
	| VInt of int
	| VInt32 of int32
	| VFloat of float
	| VReg of int
	| VThis
	| VNull
	| VSuper

let stack_delta = function
	| APush l -> List.length l
	| ASetReg _ -> 0
	| AAdd | ADivide | ASubtract | AMultiply | AMod | AStringAdd -> -1
	| AAnd | AOr | AXor | AShl | AShr | AAsr -> -1
	| ACompare | AGreater -> -1
	| AEval | ANot | AJump _ | AToInt | AToNumber | AToString | ATry _ | ASwap -> 0
	| ACondJump _ -> -1
	| AEqual | APhysEqual -> -1
	| ANew -> -1 (** only if 0 params **)
	| AObject | AInitArray -> 0 (** calculated outside **)
	| ASet -> -2
	| APop -> -1
	| AFunction _ | AFunction2 _ -> 1	
	| ADup -> 1
	| AWith _ -> -1
	| AObjGet -> -1
	| AObjSet -> -3
	| ALocalVar -> -1
	| ALocalAssign -> -2
	| AReturn -> -1
	| AFSCommand2 -> 0
	| AGetURL2 _ -> -2
	| ADeleteObj | AInstanceOf | ACast -> -1
	| AExtends | AImplements -> -2
	| AEnum2 | ATrace | AThrow -> -1
	| AGetTimer -> 1
	| AIncrement | ADecrement | AChr | AOrd | ARandom | ADelete | ATypeOf | ATargetPath -> 0
	| AObjCall | ACall | ANewMethod -> assert false
	| op -> failwith ("Unknown stack delta for " ^ (ActionScript.action_string (fun _ -> "") 0 op))
	
let write ctx op =
	let write b op =
		DynArray.add ctx.ops op;
		ctx.code_pos <- ctx.code_pos + 1;
		ctx.stack_size <- ctx.stack_size + stack_delta op;
		ctx.opt_push <- b
	in
	match op with
	| APush l when ctx.opt_push ->
		(match DynArray.last ctx.ops with
		| (APush l2) as a ->
			ctx.code_pos <- ctx.code_pos - 1;
			ctx.stack_size <- ctx.stack_size - stack_delta a;
			DynArray.delete_last ctx.ops;
			write true (APush (l2 @ l))
		| _ ->
			assert false)
	| APush _ ->
		write true op
	| _ ->
		write false op

let call ctx kind n =
	let op , n = (match kind with
		| VarReg r ->
			write ctx (APush [PReg r;PUndefined]);
			AObjCall , n + 2
		| VarStr -> 
			ACall , n + 1
		| VarObj ->
			AObjCall , n + 2
		| VarGetSet s ->
			assert false
	) in
	DynArray.add ctx.ops op;
	ctx.opt_push <- false;
	ctx.code_pos <- ctx.code_pos + 1;
	ctx.stack_size <- ctx.stack_size - n

let new_call ctx kind n  =
	let op , n = (match kind with
		| VarReg r ->
			write ctx (APush [PReg r;PUndefined]);
			ANewMethod , n + 2
		| VarStr -> 
			ANew , n + 1
		| VarObj ->
			ANewMethod , n + 2
		| VarGetSet _ ->
			assert false
	) in
	DynArray.add ctx.ops op;
	ctx.opt_push <- false;
	ctx.code_pos <- ctx.code_pos + 1;
	ctx.stack_size <- ctx.stack_size - n

let push ctx items =
	write ctx (APush (List.map (fun i ->
		match i with
		| VStr str ->
			let n = (try
				Hashtbl.find ctx.idents str
			with Not_found ->
				let n = ctx.ident_count in
				ctx.ident_count <- n + 1;
				Hashtbl.add ctx.idents str n;
				n
			) in
			if n <= 0xFF then 
				PStack n
			else
				PStack2 n
		| VInt n ->
			PInt (Int32.of_int n)
		| VInt32 n ->
			PInt n
		| VFloat f ->
			PDouble f
		| VThis ->
			PReg 1
		| VNull ->
			PNull
		| VSuper ->
			PReg 2
		| VReg n ->
			PReg n
	) items))

let rec pop ctx n =
	if n > 0 then begin
		write ctx APop;
		pop ctx (n-1);
	end

let cjmp ctx =
	write ctx (ACondJump 0);
	let start_pos = ctx.code_pos in
	let op_pos = DynArray.length ctx.ops - 1 in
	(fun() ->
		let delta = ctx.code_pos - start_pos in
		DynArray.set ctx.ops op_pos (ACondJump delta);
		ctx.opt_push <- false
	)

let jmp ctx =
	write ctx (AJump 0);
	let start_pos = ctx.code_pos in
	let op_pos = DynArray.length ctx.ops - 1 in
	(fun() ->
		let delta = ctx.code_pos - start_pos in
		DynArray.set ctx.ops op_pos (AJump delta);
		ctx.opt_push <- false
	)

let error p =
	raise (TyperInc.Error (TyperInc.Custom "Malformed expression",p))

let do_jmp ctx pos =
	write ctx (AJump (pos - (ctx.code_pos + 1)))

let setvar ?(retval=false) ctx = function
	| VarReg (-1) -> assert false (** true, false, null **)
	| VarReg n -> write ctx (ASetReg n); if not retval then write ctx APop
	| VarStr
	| VarObj as s -> 
		if retval then write ctx (ASetReg 0);
		write ctx (if s = VarStr then ASet else AObjSet);
		if retval then push ctx [VReg 0]
	| VarGetSet f ->
		push ctx [VInt 1; VSuper; VStr ("__set__" ^ f)];
		call ctx VarObj 1

let getvar ctx = function
	| VarReg (-1) -> () (** true, false, null **)
	| VarReg n -> push ctx [VReg n]
	| VarStr -> write ctx AEval
	| VarObj -> write ctx AObjGet
	| VarGetSet f ->
		push ctx [VInt 0; VSuper; VStr ("__get__" ^ f)];
		call ctx VarObj 0

let clean_stack ctx stack =
	Hashtbl.iter (fun name r ->
		if r.sp > stack then Hashtbl.remove ctx.locals name		
	) ctx.locals;
	ctx.stack <- stack	

let open_block ctx e = 
	let old_block = ctx.cur_block in
	let old_stack = ctx.stack in
	let start_size = ctx.stack_size in
	ctx.stack <- ctx.stack + 1;
	ctx.cur_block <- e;
	(fun() ->
		clean_stack ctx old_stack;
		pop ctx (ctx.stack_size - start_size);
		ctx.cur_block <- old_block
	)

let rec used_in_block curblock vname e =
	let in_lambda = ref curblock in
	let rec vloop (v,p) =
		match v with
		| EConst c ->
			(match c with
			| Ident v -> !in_lambda && v = vname
			| _ -> false)
		| ECast (v1,v2) 
		| EArray (v1,v2) ->
			vloop v1 || vloop v2
		| EBinop (_,v1,v2) ->
			vloop v1 || vloop v2
		| EField (v,_) ->
			vloop v
		| EStatic (["__With"],v) ->
			v = vname
		| EStatic _ ->
			false
		| EParenthesis v ->
			vloop v
		| EObjDecl decls -> 
			List.exists (fun (_,v) -> vloop v) decls
		| EArrayDecl vl ->
			List.exists vloop vl
		| ECall (v,vl) ->
			List.exists vloop (v :: vl)
		| ENew (v,vl) ->
			vloop v || List.exists vloop vl
		| EUnop (_,_,v) ->
			vloop v
		| EQuestion (v,v1,v2) ->
			vloop v || vloop v1 || vloop v2
		| ELambda f ->
			match f.fexpr with
			| None -> false
			| Some e ->
				let old = !in_lambda in
				in_lambda := true;
				let r = loop e in
				in_lambda := old;
				r
	and loop (e,p) =
		match e with
		| EFunction _ ->
			assert false
		| EVars (_,_,vl) ->
			List.exists (fun (_,_,v) -> 
				match v with
				| None -> false
				| Some v -> vloop v
			) vl
		| EBlock el ->
			List.exists loop el
		| EFor (el,conds,incrs,e) ->
			List.exists loop el || List.exists vloop conds || List.exists vloop incrs || loop e
		| EForIn (decl,v,e) ->
			loop decl || vloop v || loop e
		| EIf (v,e,eopt) ->
			vloop v || loop e || (match eopt with None -> false | Some e -> loop e)
		| EWhile (v,e,_) ->
			vloop v || loop e
		| ESwitch (v,cases) ->
			vloop v || List.exists (fun (v,e) -> (match v with None -> false | Some v -> vloop v) || loop e) cases
		| ETry (e,cl,fopt) ->
			loop e || List.exists (fun (n,_,e) -> vname = n || loop e) !cl || (match fopt with None -> false | Some e -> loop e)
		| EWith (v,e) ->
			vloop v || loop e
		| EReturn (Some v) ->
			vloop v
		| EVal v ->
			vloop v
		| EReturn None
		| EBreak
		| EContinue ->
			false
	in
	loop e
